home *** CD-ROM | disk | FTP | other *** search
Controls Sub CommandClear_Click...................149 Sub CommandProcess_Click.................154 Sub CommandQuit_Click....................186 Sub Form_Load............................190 Sub MenuDefaultPath_Click................205 Sub MenuHelpAbout_Click..................231 Sub MenuHelpIndex_Click..................247 Sub MenuQuit_Click.......................250 Sub TextBox_GotFocus.....................253 Subroutines Sub DeleteTemps..........................257 Sub DoTextBox3...........................267 Sub DumpSpecialCharacters................274 Sub ExpandTabs...........................300 Sub FormatVBHelp.........................346 Sub GetFileRecords.......................351 Sub GetInFileName........................420 Sub GetOutFileName.......................475 Sub GetPathFromIni.......................484 Sub GetRandomRecSize.....................496 Sub LoadBoxes............................514 Sub PrintSepLine.........................557 Sub PrintSub.............................560 Sub PutFileRecords.......................579 Sub PutTableOfContents...................670 Sub SetColors............................710 Sub SortEm...............................714 Sub SortSwap.............................755 Sub UpdateIni............................770 Sub WriteEm..............................778 Sub WriteJustSubAndFunRecords............790 '------------------------------------------------------------------------------' 1 VERSION 2.00 2 Begin Form FormFormatVB 3 Caption = "Format VB Program" 4 Height = 4360 5 Icon = FORMATVB.FRX:0000 6 Left = 1485 7 LinkMode = 1 'Source 8 LinkTopic = "Form1" 9 ScaleHeight = 3480 10 ScaleWidth = 6705 11 Top = 1520 12 Width = 6855 13 Begin CommandButton CommandClear 14 Caption = "&Clear" 15 Height = 620 16 Left = 4560 17 TabIndex = 5 18 Top = 360 19 Width = 855 20 End 21 Begin CommonDialog CMDialogFile 22 Left = 240 23 Top = 2640 24 End 25 Begin TextBox TextBox 26 Height = 735 27 Index = 1 28 Left = 1800 29 MultiLine = -1 'True 30 TabIndex = 1 31 Text = "Text1" 32 Top = 1200 33 Width = 4575 34 End 35 Begin CommandButton CommandQuit 36 Caption = "&Quit" 37 Height = 620 38 Left = 5520 39 TabIndex = 3 40 Top = 360 41 Width = 855 42 End 43 Begin CommandButton CommandProcess 44 Caption = "&Process a Visual Basic File" 45 Height = 620 46 Left = 1800 47 TabIndex = 0 48 Top = 360 49 Width = 2655 50 End 51 Begin PictureBox PictureIcon 52 AutoRedraw = -1 'True 53 AutoSize = -1 'True 54 BorderStyle = 0 'None 55 Height = 640 56 Left = 240 57 Picture = FORMATVB.FRX:0302 58 ScaleHeight = 640 59 ScaleWidth = 480 60 TabIndex = 4 61 Top = 240 62 Width = 480 63 End 64 Begin Label LabelBox 65 Alignment = 1 'Right Justify 66 AutoSize = -1 'True 67 Caption = "LabelBox" 68 Height = 195 69 Index = 1 70 Left = 840 71 TabIndex = 2 72 Top = 1200 73 Width = 795 74 End 75 Begin Menu MenuOptions 76 Caption = "&Options" 77 Begin Menu MenuDefaultPath 78 Caption = "&Set Default Path" 79 End 80 End 81 Begin Menu MenuQuit 82 Caption = "&Quit" 83 End 84 Begin Menu MenuHelp 85 Caption = "&Help" 86 Begin Menu MenuHelpIndex 87 Caption = "&Index" 88 Shortcut = {F1} 89 End 90 Begin Menu MenuHelpSep 91 Caption = "-" 92 End 93 Begin Menu MenuHelpAbout 94 Caption = "&About" 95 End 96 End 97 End '------------------------------------------------------------------------------' 98 ' FormatVB.Frm - Format VB .txt file 99 ' 92/10/03 Copyright 1992, Larry Rebich, The Bridge, Inc. 100 ' 92/10/04 Add Table of Contents 101 ' 92/10/13 Use *.txt files 102 ' 92/10/16 Fix problems with Left Margin and Tabs Expansion 103 ' 92/12/01 Convert to VB 2.0, use .Frm files 104 ' 92/12/07 Add Captions to Table of Contents 105 ' 92/12/09 Add Help 106 ' 92/12/09 Send a copy to Inside Visual Basic, Cobb Group 108 DefInt A-Z 'default data type is integer 109 Const Version = "1.0" 'version 110 Const VersionDate = "December, 1992" 'version date, 92/12/09 111 Declare Function WritePrivateProfileString Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpString As String, ByVal lplFileName As String) As Integer 112 Declare Function GetPrivateProfileString Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Integer, ByVal lpFileName As String) As Integer 113 Const Pgm$ = "FormatVB Options" 'used in formatvb.ini file 114 Const Which$ = "Default Path" 'used in formatvb.ini as well 115 Const FileIni$ = "FormatVB.Ini" 'save default path name here, Windows Directory 116 Const FormatVBHelpFile = "FormatVB.Hlp" 'help file name 117 Const TempFName$ = "~ormatVB" 'temporary file name 118 Const MaxSubs = 1500 'maximum number of sub, functions - increase if necessary 119 Dim Recs$(1 To MaxSubs) 'store subs, functions here 120 Dim RecCount As Integer 'number of records read 121 Dim LFlag(1 To MaxSubs) 'flag, 0=normal text line 122 ' 1=Sub, Control_ [contains underline] 123 ' 3=Sub, Standard 124 ' 5=End Sub 125 ' 7=Function 126 ' 8=End Function 127 Const xSub$ = "SUB" 'type 1 or 3 128 Const xFun$ = "FUNCTION" 'type 7 129 Const xEnd$ = "END" 'type 5 or 8 130 Dim SortRec$(1 To MaxSubs) 'put sub/function records here 131 Dim SortCt(1 To MaxSubs) 'and its record number 132 Dim SortInSubCount(1 To MaxSubs)'and sub/function contains this many 133 Dim SortLFlag(1 To MaxSubs) 'lflag here, type of sub/function 134 Dim SortThisMany As Integer 'how many subs and functions 135 Dim FirstSub As Integer 'first line containing sub or function 136 Dim InFile As String 'input file name 137 Dim OutFile As String 'output file 138 Dim RandomFile As String 'store them here randomly 139 Dim RandomRecSize As Integer 'random file record size 140 Dim LongestLen As Integer 'Longest line length 141 Dim LongestRec As Integer 'longest record number 142 Dim GotInFile As Integer 'we have a file switch 143 Dim PathName As String 'use this path name 144 Dim InCmDialog As Integer 'in here now switch 145 Dim VBFrmFile As Integer 'is it a VB 2.0 .frm file 146 Dim SepLine As String 'separator line 147 Dim AuthorIsUser As Integer 'is it the author '------------------------------------------------------------------------------' 149 Sub CommandClear_Click () 150 For i = 1 To 3 'clear the text boxes 151 TextBox(i).Text = "" 152 Next 153 End Sub '------------------------------------------------------------------------------' 154 Sub CommandProcess_Click () 155 Screen.MousePointer = HourGlass 'tell 'em to wait 156 CommandProcess.Enabled = False 'dim this control 157 CommandQuit.Enabled = False 'dim this one as well 158 CommandClear.Enabled = False 159 MenuOptions.Enabled = False 'dim this menu items 160 MenuQuit.Enabled = False 161 MenuHelp.Enabled = False 162 PictureIcon.SetFocus 'so no focus on text box 163 CommandClear_Click 'clear the text boxes 164 GetInFileName 'get the file to process 165 If GotInFile = False Then GoTo ExitThis 'open failed, cancel pressed 166 Screen.MousePointer = HourGlass 'back on in case set off in Dialog 167 GetOutFileName 'get output file name from input 168 GetRandomRecSize 'get largest line size 169 GetFileRecords 'read the input file 170 WriteJustSubAndFunRecords 'write a temporary file 171 SortEm 'sort the subroutine and function names 172 PutFileRecords 'build the output file 173 Beep 'tell 'em we are done 174 Screen.MousePointer = Default 'back to normal 175 DeleteTemps 'delete temporary files 176 ExitThis: 'if cancel pressed 177 CommandProcess.Enabled = True 'back on 178 CommandQuit.Enabled = True 'back on 179 CommandClear.Enabled = True 180 MenuOptions.Enabled = True 181 MenuQuit.Enabled = True 182 MenuHelp.Enabled = True 183 CommandProcess.SetFocus 'and light it 184 Screen.MousePointer = Default 'done waiting 185 End Sub '------------------------------------------------------------------------------' 186 Sub CommandQuit_Click () 187 FormatVBHelp Help_Quit, 0& 'dump help file if active 188 End 'quit 189 End Sub '------------------------------------------------------------------------------' 190 Sub Form_Load () 191 CenterForm Me, 0, 0 'center on screen 192 GetPathFromIni 'get default path from ini 193 SetColors 'some color is nice 194 LoadBoxes 'set control locations 195 SepLine = "'" + String$(78, "-") + "'" 'separates subs and functions 196 RandomFile = TempFName + ".rnd" 'temp random file name 197 x$ = Environ$("AUTHOR") 'is author the user 198 If UCase$(x$) = UCase$("LarryRebich") Then 199 AuthorIsUser = True 'environ has author's name 200 End If 201 Show 'show 'em 202 Refresh 'force display before asking for file 203 CommandProcess_Click 'start 'em off with file dialog 204 End Sub '------------------------------------------------------------------------------' 205 Sub MenuDefaultPath_Click () 206 'allow a default path name to be entered 207 P$ = "Enter a default path name, or press enter to retain the current path." 208 t$ = "Default Path" 209 TryAgain: 210 Value$ = InputBox$(P$, t$, PathName) 211 If Value$ = PathName Then Exit Sub 'no change 212 If Value$ = "" Then Exit Sub 'cancel pressed 213 If Right$(Value$, 1) <> "\" Then 'add ending \ if needed 214 Value$ = Value$ + "\" 215 End If 216 On Error GoTo BadDir 'if no file or bad name 217 x$ = Dir$(Value$ + "*.*") 'get any file 218 If x$ = "" Then 'any file in directory? 219 Msg$ = "No files in directory: " + Value$ 220 MsgBox Msg$, MB_IconExclamation, "Invalid Directory" 221 GoTo TryAgain 222 End If 223 PathName = Value$ 'store the new value 224 TextBox(1).Text = " " + PathName 'into text box to display it 225 UpdateIni Value$ 'update the .ini file 226 Exit Sub 227 BadDir: 228 MsgBox Error$, MB_IconExclamation, "Failed to Find Any Files" 229 Resume TryAgain 230 End Sub '------------------------------------------------------------------------------' 231 Sub MenuHelpAbout_Click () 232 Dim Msg As String, Nl As String * 2 'some info about the author 233 Dim Sp As String 'some spaces 234 Sp = String$(9, " ") 235 Nl = Chr$(13) + Chr$(10) 236 Msg = "FormatVB - Format Visual Basic Text" + Nl 237 Msg = Msg + "Version: " + Version + " " + VersionDate + Nl + Nl 238 Msg = Msg + Sp + "Copyright " + Format$(Now, "yyyy") + Nl + Nl 239 Msg = Msg + Sp + "Larry Rebich" + Nl 240 Msg = Msg + Sp + "The Bridge, Inc." + Nl 241 Msg = Msg + Sp + "199 California Drive" + Nl 242 Msg = Msg + Sp + "Millbrae, CA 94030" + Nl + Nl 243 Msg = Msg + Sp + "415-697-2730" + Nl 244 Msg = Msg + Sp + "Fax: 415-692-3921" 245 MsgBox Msg, MB_IconQuestion, "About FormatVB" 246 End Sub '------------------------------------------------------------------------------' 247 Sub MenuHelpIndex_Click () 248 FormatVBHelp Help_Context, 10& 'help requested 249 End Sub '------------------------------------------------------------------------------' 250 Sub MenuQuit_Click () 251 CommandQuit_Click 'end it 252 End Sub '------------------------------------------------------------------------------' 253 Sub TextBox_GotFocus (Index As Integer) 254 If InCmDialog = True Then Exit Sub 'can't set focus while showing another screen 255 CommandProcess.SetFocus 'don't allow focus on the text boxes 256 End Sub '------------------------------------------------------------------------------' 257 Sub DeleteTemps () 258 Dim Temp As String 259 Temp = TempFName + ".*" 'temp file names to delete 260 ' If AuthorIsUser Then 'for testing, delete the temps? 261 ' Msg$ = "Delete temporary files? " 262 ' MsgRtn% = MsgBox(Msg$, MB_YesNo + MB_IconQuestion, "Kill " + Temp) 263 ' If MsgRtn% = IDNo Then Exit Sub 'said no, so don't delete 264 ' End If 265 Kill PathName + Temp 'delete all temp files 266 End Sub '------------------------------------------------------------------------------' 267 Sub DoTextBox3 (RecCountPut As Integer, TheRec As String, Force As Integer) 268 Dim RecNum As String 269 If RecCountPut Mod 9 = 0 Or Force Then 'only every 9 or forced 270 RecNum = Format$(RecCountPut, "####") 'record number 271 TextBox(3).Text = RecNum + " " + TheRec 'now into text box 272 End If 273 End Sub '------------------------------------------------------------------------------' 274 Sub DumpSpecialCharacters (Rec As String) 275 'was needed for printer output, not needed for VB 2.0 Text Output 276 If VBFrmFile Then Exit Sub 'little faster 277 Dim Lf As String * 1 'line feed 278 Dim Cr As String * 1 'carriage return 279 Dim Ff As String * 1 'form feed 280 Dim x As String 281 Dim y As Integer 282 Lf = Chr$(10) 283 Cr = Chr$(13) 284 Ff = Chr$(12) 285 x = " " + Rec 'into x and add a blank 286 While InStr(x, Lf) 'dump line feeds 287 y = InStr(x, Lf) 288 x = Mid$(x, 1, y - 1) + Mid$(x, y + 1) 289 Wend 290 While InStr(x, Cr) 'dump carriage returns 291 y = InStr(x, Cr) 292 x = Mid$(x, 1, y - 1) + Mid$(x, y + 1) 293 Wend 294 While InStr(x, Ff) 'dump form feeds 295 y = InStr(x, Ff) 296 x = Mid$(x, 1, y - 1) + Mid$(x, y + 1) 297 Wend 298 Rec = Mid$(x, 2) 'dump blank that was added 299 End Sub '------------------------------------------------------------------------------' 300 Sub ExpandTabs (Rec As String) 301 Static Lm As Integer 'previous left margin 302 Dim SkipLmSet As Integer 'skip resetting setting left margin 303 Dim t As String * 1 'tab 304 Dim s As String 'spacer 305 Dim x As String 'work string 306 Dim ExtraChars As String 'based upon left margin 307 ExtraChars = "" 'clear for now 308 t = Chr$(9) 'tab character 309 SkipLmSet = False 'switch, off if any tab 310 If Lm > 1 Then 'if margin greater than this 311 If InStr(Rec, t) > 0 Then 'and if there is a tab 312 ExtraChars = String$(Lm - 1, " ") 'add some more characters 313 SkipLmSet = True 'and skip setting left margin 314 End If 315 End If 316 If InStr(Rec, t) > 0 Then 'any tab 317 Rec = ExtraChars + Rec 'add the extra characters to the record 318 End If 319 x = " " + Rec 'one blank 320 CountTabs = 0 'count tabs 321 While InStr(x, t) > 0 'expand the tabs 322 CountTabs = CountTabs + 1 'double second tab 323 If CountTabs = 1 Then 324 s = String$(4, " ") 325 Else 326 s = String$(8, " ") 327 End If 328 i = InStr(x, t) 329 x = Mid$(x, 1, i - 1) + s + Mid$(x, i + 1) 330 Wend 331 Rec = Mid$(x, 2) 'dump extra blank 332 If CountTabs > 4 Then 'should not get here!! 333 Msg$ = "Found " + Format$(CountTabs, "##0") + " tabs in line:" + Str$(RecCount) 334 Msg$ = Msg$ + " Record: |" + Rec + "|. The line may not expand correctly." 335 MsgBox Msg$, MB_IconExclamation, "Too Many Tabs?" 336 End If 337 If SkipLmSet = False Then 338 x = Mid$(x, 2) 'and work variable 339 x = RTrim$(x) 'get number of leading blanks 340 sl = Len(x) 'length before dumping leading blanks 341 x = LTrim$(x) 'dump leading blanks 342 el = Len(x) 'length without leading blanks 343 Lm = sl - el + 1 'left margin 344 End If 345 End Sub '------------------------------------------------------------------------------' 346 Sub FormatVBHelp (WCmd%, dwData As Long) 347 Screen.MousePointer = HourGlass 'show 'em we are working 348 x% = WinHelp(hWnd, App.Path + FormatVBHelpFile, WCmd%, ByVal dwData) 349 Screen.MousePointer = Default 'done loading 350 End Sub '------------------------------------------------------------------------------' 351 Sub GetFileRecords () 'read the records 352 ReDim a$(1 To 200) 'array for parse 353 Dim Rec As String 'read ascii file into here 354 Dim Blanks As String 'bunch of blanks 355 Blanks = String$(RandomRecSize, " ") 'fill random file with recs and blanks 356 Erase LFlag 'zeros into this array 357 RecCount = 0 'record counter 358 f = FreeFile 'file id 359 Open PathName + InFile For Input As #f 360 f2 = FreeFile 'next file id 361 Open PathName + RandomFile For Output As #f2 'work with a new one 362 Close #f2 363 Kill PathName + RandomFile 'dump the one just opened 364 Open PathName + RandomFile For Random As #f2 Len = RandomRecSize + 2 365 FirstSub = 0 'this will contain the rec number of the first sub 366 While Not EOF(f) 'read until end of file 367 Line Input #f, Rec 'read the record 368 DumpSpecialCharacters Rec 'get rid of special characters 369 x$ = Trim$(Rec) 'don't process completely blank records 370 If x$ <> "" Then 371 RecCount = RecCount + 1 'bump record counter 372 ExpandTabs Rec 373 Rec = Left$(Rec + Blanks, RandomRecSize) 'add blanks to pad record 374 Put #f2, RecCount, Rec 'store in random file 375 x$ = UCase$(LTrim$(Rec)) 'work with it to see if Sub, End, etc. 376 If Left$(x$, 1) <> "'" Then 'if starts with comment then skip 377 anum = Parse(x$, a$(), " ") 'split apart 378 Select Case a$(1) 'first 379 Case xSub$ 'sub 380 GoSub IfFirstSubFun 'is it the first one 381 If InStr(a$(2), "_") > 0 Then 382 LFlag(RecCount) = 1 'command_event 383 Else 384 LFlag(RecCount) = 3 'standard sub 385 End If 386 Recs(RecCount) = Rec 'store subs into matrix 387 TextBox(2).Text = " " + Rec 388 Case xFun$ 'function 389 GoSub IfFirstSubFun 390 LFlag(RecCount) = 7 391 Recs(RecCount) = Rec 392 TextBox(2).Text = " " + Rec 393 Case xEnd$ 394 Select Case a$(2) 395 Case xSub$ 'end sub 396 LFlag(RecCount) = 5 397 Case xFun$ 'end function 398 LFlag(RecCount) = 8 399 End Select 400 Case Else 'nothing special 401 LFlag(RecCount) = 0 402 DoTextBox3 RecCount, LTrim$(Rec), False 403 Refresh 404 End Select 405 Else 406 DoTextBox3 RecCount, LTrim$(Rec), False 407 End If 408 End If 409 Wend 410 DoTextBox3 RecCount, LTrim$(Rec), True 'in case not shown 411 Close #f, #f2 'done with input and done creating random file 412 Reset 413 'in case there were no subs or functions [constant.txt!] 414 If FirstSub = 0 Then FirstSub = RecCount + 1 415 Exit Sub 416 IfFirstSubFun: 417 If FirstSub = 0 Then FirstSub = RecCount 'first sub record number 418 Return 419 End Sub '------------------------------------------------------------------------------' 420 Sub GetInFileName () 421 Dim Fltr As String, f As Integer, Rec1 As String 422 InCmDialog = True 'get file to process 423 CmDialogFile.DefaultExt = ".frm" 'default extension 424 CmDialogFile.DialogTitle = "VB Input File" 425 CmDialogFile.Filename = "*.frm" 426 Fltr = "" 427 Fltr = Fltr & "VB Forms [*.frm]|*.frm|" 'for VB 2.0 92/12/01 428 Fltr = Fltr & "Bas Files [*.bas]|*.bas|" 429 Fltr = Fltr & "Sub Files [*.sub]|*.sub|" 430 Fltr = Fltr & "Glb Files [*.glb]|*.glb|" 431 Fltr = Fltr & "Txt Files [*.txt]|*.txt|" 432 Fltr = Fltr & "Prn Files [*.prn]|*.prn|" 433 Fltr = Fltr & "All Files [*.*]|*.*|" 434 CmDialogFile.Filter = Fltr 435 CmDialogFile.Flags = OFN_READONLY Or OFN_HIDEREADONLY Or OFN_PATHMUSTEXIST 436 CmDialogFile.CancelError = True 'allow cancel key to cause error 437 CmDialogFile.InitDir = PathName 438 GotInFile = True 'say we got one 439 On Error Resume Next 'in case cancel pressed 440 CmDialogFile.Action = DLG_FILE_OPEN 'do it 441 If Err = 0 Then 'ok, got name 442 InFile = CmDialogFile.Filetitle 443 PathName = CmDialogFile.Filename 444 PathName = Mid$(PathName, 1, InStr(PathName, InFile) - 1) 445 If Right$(PathName, 1) <> "\" Then 446 PathName = PathName + "\" 447 End If 448 If InStr(LCase$(InFile), ".frm") > 0 Then 'VB 2.0 449 f = FreeFile 'check to see if it is valid 450 Open PathName & InFile For Input As #f 451 Line Input #f, Rec1 452 Rec1 = Trim$(Rec1) 453 If Rec1 <> "VERSION 2.00" Then 454 GotInFile = False 455 Beep 456 TextBox(1).Text = " " + LCase$(PathName + InFile) + " - Not a VB 2.0 File" 457 Else 458 GoSub PathAndIniUpdate 459 VBFrmFile = True 'it is a VB .frm file 460 End If 461 Else 'not VB 2.0 462 GoSub PathAndIniUpdate 463 VBFrmFile = False 'not VB .frm file 464 End If 465 ElseIf Err = 32755 Then 'cancel pressed 466 GotInFile = False 467 End If 468 InCmDialog = False 'done with this process 469 Exit Sub 470 PathAndIniUpdate: 'ok, store it 471 UpdateIni PathName 'store it 472 TextBox(1).Text = " " + LCase$(PathName + InFile) + " - Input" 473 Return 474 End Sub '------------------------------------------------------------------------------' 475 Sub GetOutFileName () 'get OutFile from InFile 476 Dim x As String 477 If InStr(InFile, ".") > 0 Then 'find period 478 x = Mid$(InFile, 1, InStr(InFile, ".") - 1) 479 OutFile = x + ".wrk" 480 Else 481 OutFile = "FormatVB.Wrk" 'should not get here 482 End If 483 End Sub '------------------------------------------------------------------------------' 484 Sub GetPathFromIni () 485 Dim Buf As Integer, Value As String, Num As Integer 486 Buf = 64 'read the .ini file 487 Value = Space$(Buf) 488 Num = GetPrivateProfileString(Pgm$, Which, "", Value, Buf, FileIni) 489 If Num > 0 Then 490 PathName = Trim$(Mid$(Value, 1, Num)) 491 Else 492 PathName = "" 'no .ini value found 493 End If 494 TextBox(1).Text = " " + PathName 'display it 495 End Sub '------------------------------------------------------------------------------' 496 Sub GetRandomRecSize () 497 'get the longest line, needed to set the random record length 498 Dim x As String 499 Dim z As Integer 500 f = FreeFile 'get the largest line number 501 Open PathName + InFile For Input As #f 502 While Not EOF(f) 503 Line Input #f, x 'read line 504 DumpSpecialCharacters x 'drop special characters 505 ExpandTabs x 'expand it 506 x = RTrim$(x) 'dump any trailing blanks 507 z = Len(x) 'size of remaining record 508 If RandomRecSize < z Then 'if x longer then use save it 509 RandomRecSize = z 'use it 510 End If 511 Wend 512 Close #f 'done, close it 513 End Sub '------------------------------------------------------------------------------' 514 Sub LoadBoxes () 515 Static HereBefore As Integer 'set up the screen 516 Of = 100 517 If HereBefore = False Then 'do this just once 518 HereBefore = True 519 For i = 2 To 3 520 Load LabelBox(i) 'load the extra labels and boxes 521 LabelBox(i).Visible = True 522 Load TextBox(i) 523 TextBox(i).Visible = True 524 Next 525 For i = 1 To 3 526 If i < 3 Then 527 TextBox(i).Height = CommandProcess.Height * .75 528 Else 529 TextBox(i).Height = CommandProcess.Height * 1.5 530 TBLeft = TextBox(i).Width * .35 531 TextBox(i).Width = TextBox(1).Width + TBLeft 532 End If 533 Next 534 End If 535 TextBox(1).Top = CommandProcess.Top + CommandProcess.Height + Of * 2 536 TextBox(1).Left = CommandProcess.Left 537 TextBox(2).Left = TextBox(1).Left 538 TextBox(3).Left = TextBox(1).Left - TBLeft 539 TextBox(2).Top = TextBox(1).Top + TextBox(1).Height + Of 540 TextBox(3).Top = TextBox(2).Top + TextBox(1).Height + Of 541 LabelBox(1).Caption = "File" 542 LabelBox(2).Caption = "Routine" 543 LabelBox(3).Caption = "Line" 544 For i = 1 To 3 545 If i > 1 Then 546 TextBox(i).Text = "" 547 End If 548 LabelBox(i).Top = TextBox(i).Top + Of 549 LabelBox(i).Left = TextBox(i).Left - LabelBox(i).Width - Of * 2 550 If i = 3 Then 551 LabelBox(i).Left = LabelBox(i).Left - TBLeft 552 End If 553 LabelBox(i).BackColor = BackColor 554 LabelBox(i).ForeColor = ForeColor 555 Next 556 End Sub '------------------------------------------------------------------------------' 557 Sub PrintSepLine (f As Integer) 558 PrintSub f, SepLine, 0 'print a separator line 559 End Sub '------------------------------------------------------------------------------' 560 Sub PrintSub (f As Integer, PLine As String, LineNumber As Integer) 561 ' common print subroutine 562 Static HoldLine As String 563 If HoldLine = SepLine And PLine = SepLine Then 'no two sep together 564 Exit Sub 565 End If 566 HoldLine = PLine 567 Dim Counter As String 568 If LineNumber > 0 Then 'print line number, unless zero 569 Counter = Right$(" " + Format$(LineNumber, "####"), 4) 570 Print #f, Counter; " "; PLine 571 If Len(PLine) > LongestLen Then 572 LongestRec = LineNumber 'new value 573 LongestLen = Len(PLine) 'and save for compare 574 End If 575 Else 576 Print #f, PLine 'don't count this line, usually a separator 577 End If 578 End Sub '------------------------------------------------------------------------------' 579 Sub PutFileRecords () 580 ' write them to the .wrk file now, almost done 581 Dim HaveBeginSw As Integer, HaveEndSw As Integer 582 LongestRec = 0 'reset this 583 LongestLen = 0 'and this 584 RecCountPut = 0 'record counter 585 CommentStringLen = 40 586 CommentString$ = String$(CommentStringLen, "'") 587 TextBox(1).Text = " " + LCase$(PathName + OutFile) + " - Output" 588 f = FreeFile 589 Open PathName + OutFile For Output As #f 590 f2 = FreeFile 'random file 591 Open PathName + RandomFile For Random As #f2 Len = RandomRecSize + 2 592 If SortThisMany >= 1 Then 593 PutTableOfContents f, f2 'do the table of contents 594 PrintSepLine f 595 End If 596 If FirstSub > 1 Then 'any general 597 For j = 1 To FirstSub - 1 'general info 598 GoSub WriteRec 599 DoTextBox3 RecCountPut, x$, False 600 Next 601 PrintSepLine f 602 End If 603 For i = 1 To SortThisMany 'do Command_Click type first 604 If SortLFlag(i) = 1 Then 605 For j = SortCt(i) To SortCt(i) + SortInSubCount(i) - 1 606 GoSub WriteRec 607 GoSub IntoTextBox 608 Next 609 PrintSepLine f 610 End If 611 Next 612 For i = 1 To SortThisMany 'do normal subs next 613 If SortLFlag(i) = 3 Then 614 For j = SortCt(i) To SortCt(i) + SortInSubCount(i) - 1 615 GoSub WriteRec 616 GoSub IntoTextBox 617 Next 618 PrintSepLine f 619 End If 620 Next 621 For i = 1 To SortThisMany 'do functions next 622 If SortLFlag(i) = 7 Then 623 For j = SortCt(i) To SortCt(i) + SortInSubCount(i) - 1 624 GoSub WriteRec 625 GoSub IntoTextBox 626 Next 627 PrintSepLine f 628 End If 629 Next 630 'wrap up 631 x$ = String$(4, " ") 632 m$ = "####" 633 PrintSub f, Right$(x$ + Format$(RecCountPut, m$), 4) + " lines in file " + LCase$(PathName + OutFile), 0 634 PrintSub f, Right$(x$ + Format$(LongestLen, m$), 4) + " characters in longest line", 0 635 PrintSub f, Right$(x$ + Format$(LongestRec, m$), 4) + " first longest line", 0 636 Close 'close any open files 637 Reset 'force buffers to disk 638 Exit Sub 639 WriteRec: 'write the temp file 640 RecCountPut = RecCountPut + 1 641 Get #f2, j, x$ 642 x$ = RTrim$(x$) 643 y$ = LTrim$(x$) 'dump long strings with only ''''' 644 If Left$(y$, CommentStringLen) <> CommentString$ Then 645 PrintSub f, x$, RecCountPut 646 If VBFrmFile Then 'is this a VB 2.0 form 647 If HaveEndSw = False Then 'only do this once 648 If HaveBeginSw = False Then 649 If Left$(LCase$(x$), 5) = "begin" Then 650 HaveBeginSw = True 651 End If 652 Else 653 If Left$(LCase$(x$), 3) = "end" Then 654 HaveEndSw = True 655 PrintSepLine f 'separator after last end 656 End If 657 End If 658 End If 659 End If 660 End If 661 Return 662 IntoTextBox: 'show record in text box 663 If j = SortCt(i) Then 'sub or function name 664 TextBox(2).Text = " " + x$ 665 Else 'just an ordinary record 666 DoTextBox3 RecCountPut, LTrim$(x$), True 667 End If 668 Return 669 End Sub '------------------------------------------------------------------------------' 670 Sub PutTableOfContents (f As Integer, f2 As Integer) 671 'write the table of contents to the .wrk file 672 Dim Toc As String 'sub into here 673 Dim LToc As String 'local 674 Dim HoldFlag As Integer 'extra line on type break 675 ReDim SecType(1 To 7) As String 'section names stored here 676 Dim SecLen As Integer 'store section len here 677 SecType(1) = " Controls " 'section headings 678 SecType(3) = " Subroutines " 679 SecType(7) = " Functions " 680 SecLen = Len(SecType(1)) 'longest one 681 f9 = FreeFile 'work file 682 TocOffset = SecLen 'TOC offset 683 ReDim AToc(1 To 500) As String 684 Open PathName + TempFName + ".toc" For Output As #f9 685 StartLine = FirstSub 'first subroutine line number 686 For i = 1 To SortThisMany 'this many to put in Toc 687 Get #f2, SortCt(i), Toc 'get the sub 688 Toc = LTrim$(RTrim$(Toc)) 689 aTocNum = Parse(Toc, AToc(), " ")'just sub and name 690 LToc = Left$(AToc(1) + " " + AToc(2) + String$(40, "."), 40) 691 LToc = String$(TocOffset, " ") + LToc + Right$("....." + Format$(StartLine, "####"), 4) 692 LToc = SecType(SortLFlag(i)) + Mid$(LToc, TocOffset) 'add caption 693 SecType(SortLFlag(i)) = String$(SecLen, " ")'kill it after first one 694 If i > 1 Then 'not first time 695 If HoldFlag <> SortLFlag(i) Then 'extra line on Flag break 696 HoldFlag = SortLFlag(i) 697 Print #f9, "" 'blank line between types 698 Print #f, "" 699 End If 700 Else 701 HoldFlag = SortLFlag(i) 'first time, set hold flag 702 End If 703 Print #f9, LToc 'work file 704 Print #f, LToc 'real file 705 StartLine = StartLine + SortInSubCount(i) 706 Next 707 Print #f, "" 'extra line after TOC 708 Close #f9 'close temp file 709 End Sub '------------------------------------------------------------------------------' 710 Sub SetColors () 711 BackColor = Application_Workspace 'some color is nice 712 ForeColor = Window_Text 713 End Sub '------------------------------------------------------------------------------' 714 Sub SortEm () 715 Erase SortInSubCount 'clear the arrays 716 Erase SortRec 717 Erase SortCt 718 SortThisMany = 0 719 For i = 1 To RecCount 720 Select Case LFlag(i) 'build sort array 721 Case 1, 3, 7 'sub or function 722 SortThisMany = SortThisMany + 1 723 ReDim RecArray$(1 To 500) 724 x$ = Recs(i) 'into unindexed string 725 RecArrayNumber = Parse(x$, RecArray$(), " ") 726 x$ = RecArray$(1) + " " + RecArray$(2) 727 SortRec(SortThisMany) = x$ 'the sub, function 728 SortCt(SortThisMany) = i 'record number 729 SortLFlag(SortThisMany) = LFlag(i) 730 SortInSubCount(SortThisMany) = SortInSubCount(SortThisMany) + 1 731 Case Else 'all other types 732 If SortThisMany > 0 Then 'count records in sub or function 733 SortInSubCount(SortThisMany) = SortInSubCount(SortThisMany) + 1 734 End If 735 End Select 736 Next 737 WriteEm PathName + TempFName + ".nrt" 'write unsorted temp file for debug 738 For i = 1 To SortThisMany - 1 'sort decending by name, end up ascending 739 For j = i + 1 To SortThisMany 740 If SortRec(i) < SortRec(j) Then 'swap them 741 SortSwap i, j 742 End If 743 Next 744 Next 745 WriteEm PathName + TempFName + ".srt" 'write sort by name for debug 746 For i = 1 To SortThisMany - 1 'sort by type, end up ascending 747 For j = i + 1 To SortThisMany 748 If SortLFlag(i) >= SortLFlag(j) Then 'swap them 749 SortSwap i, j 750 End If 751 Next 752 Next 753 WriteEm PathName + TempFName + ".typ" 'write final sort for debug 754 End Sub '------------------------------------------------------------------------------' 755 Sub SortSwap (i As Integer, j As Integer) 756 Dim Tmp As String, TmpCt As Integer 757 Tmp = SortRec(i) 'swap sort array elements 758 SortRec(i) = SortRec(j) 759 SortRec(j) = Tmp 760 TmpCt = SortCt(i) 761 SortCt(i) = SortCt(j) 762 SortCt(j) = TmpCt 763 TmpCt = SortInSubCount(i) 764 SortInSubCount(i) = SortInSubCount(j) 765 SortInSubCount(j) = TmpCt 766 TmpCt = SortLFlag(i) 767 SortLFlag(i) = SortLFlag(j) 768 SortLFlag(j) = TmpCt 769 End Sub '------------------------------------------------------------------------------' 770 Sub UpdateIni (Value As String) 771 Dim Result As Integer 'update the .ini file 772 Result = WritePrivateProfileString(Pgm$, Which$, LCase$(Value$), FileIni$) 773 If Result = 0 Then 'should not get an error 774 Msg$ = "Could not update " + UCase$(Which$) + "=" + UCase$(Value$) + " in File: " + UCase$(FileIni$) 775 MsgBox Msg$, MB_IconExclamation, "Update INI Error" 776 End If 777 End Sub '------------------------------------------------------------------------------' 778 Sub WriteEm (WFile As String) 779 Dim x1 As String, x2 As String, x3 As String 780 f = FreeFile 'write temporary files, for debug 781 Open WFile For Output As #f 782 For i = 1 To SortThisMany 783 x1 = Right$(" " + Trim$(Str$(SortCt(i))), 4) 'starting number 784 x2 = Right$(" " + Trim$(Str$(SortInSubCount(i))), 4) 'records in sub 785 x3 = Right$(" " + Trim$(Str$(SortLFlag(i))), 1) 'type 786 Print #f, x1; " "; x2; " "; x3; " "; SortRec(i) 787 Next 788 Close #f 789 End Sub '------------------------------------------------------------------------------' 790 Sub WriteJustSubAndFunRecords () 791 f = FreeFile 'temporary file 792 Open PathName + TempFName + ".lst" For Output As #f 793 For i = 1 To RecCount 794 If Len(Recs(i)) > 0 Then 795 Print #f, FirstSub; " "; LFlag(i); " "; Recs(i) 796 End If 797 Next 798 Close #f 799 Reset 800 End Sub '------------------------------------------------------------------------------' 800 lines in file g:\user\cdproj\sharew\vb\formatvb\formatvb.wrk 240 characters in longest line 112 first longest line 
